--{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Math
import Vector2D
import Point2D
import Size
import Color
import Rectangle
import RenderEngine
import StreamEngine
import Projectable
import Rectangle

import Data.VectorSpace hiding (Scalar)
import Data.AffineSpace
import qualified Data.Stream as S

import Control.Applicative
import Control.Arrow
import Data.Maybe
import Data.Monoid
import Data.List

-------------------------------------------------------------------------------

--data ID = PADDLE | BALL | WALL deriving (Show,Eq,Ord)

type ID = Int

class HasBounds a where
  getBounds :: a -> Rectangle
--  mapBounds :: (Rectangle->Rectangle) -> a -> a
--  withBounds :: Rectangle -> a -> a
--  withBounds = mapBounds . const  

class HasID a where
  getID :: a -> ID

{-
data Actor a = Actor { actorId :: !ID
                     , actorPos :: !Offset2
                     , actorVel :: !Velocity2
                     , actorBounds :: !Rectangle
                     , actorData :: !a 
                     }
-}

allCollisionPairs :: [a] -> [(a,a)]
allCollisionPairs []     = []
allCollisionPairs (a:[]) = []
allCollisionPairs as     = aux as (tail as)
  where
    aux bs@(b:_) (c:cs) = (b,c):aux bs cs
    aux (_:[])   []     = []
    aux (_:bs)   []     = allCollisionPairs bs

broadPhaseCollision :: [(Rectangle,ID)] -> [(ID, ID)]
broadPhaseCollision as = map onlyIDs . filter boundsOverlap $ allCollisionPairs as
  where
    onlyIDs = snd *** snd
    boundsOverlap ((r1,_),(r2,_)) = r1 `intersects` r2

-------------------------------------------------------------------------------

ballRadius :: Scalar 
ballRadius = 10

ballDiameter :: Scalar 
ballDiameter = 2*ballRadius

ballSize :: Size
ballSize = size ballDiameter ballDiameter

paddleWidth :: Scalar
paddleWidth = 100

paddleHeight :: Scalar
paddleHeight = 10

paddleSize :: Size
paddleSize = size paddleWidth paddleHeight

data Actor = Ball { actorID :: !ID
                  , actorPos :: !Point2 
                  } 
           | Paddle { actorID :: !ID
                    , actorPos :: !Point2
                    }
           deriving Show

instance HasBounds Actor where
  getBounds ball@Ball{}     = pivotRect (actorPos ball) ballSize (vector2 0.5 0.5)
  getBounds paddle@Paddle{} = pivotRect (actorPos paddle) paddleSize (vector2 0.5 0.5)

data GameSample = GameSample { balls :: ![Actor]
                             , paddle :: !Actor
                             , gameLost  :: !Incident
                             , gameExit :: !Incident
                             , collisions :: ![(ID,ID)]
                             }
                  deriving Show

type Game = Signal GameSample

--withBallPos :: Point2 -> GameSample -> GameSample
--withBallPos v g = g { actorPos = v }

--withGameLost :: Incident -> GameSample -> GameSample
--withGameLost v g = g { gameLost = v }

withGameExit :: Incident -> GameSample -> GameSample
withGameExit v g = g { gameExit = v }

{-
withPicture :: Picture -> GameSample -> GameSample
withPicture v g = g { picture = v }
-}

-------------------------------------------------------------------------------

wallLeft   :: Scalar 
wallRight  :: Scalar 
wallBottom :: Scalar 
wallTop    :: Scalar 
wallSize   :: Scalar 
wallHeight :: Scalar 
wallWidth  :: Scalar 

initBallSpeed :: Scalar 
initBallPos   :: Point2 
initPaddlePos :: Point2 

wallLeft   = worldMinX+10
wallRight  = worldMaxX-10
wallBottom = worldMinY+10
wallTop    = worldMaxY-10
wallSize   = 5
wallHeight = wallTop - wallBottom
wallWidth  = wallRight - wallLeft

initBallSpeed = -200
initBallPos   = point2 0 0
initPaddlePos = point2 0 (wallBottom+50)

-------------------------------------------------------------------------------

isColliding :: Ordering -> Scalar -> Scalar -> Scalar -> Bool
isColliding ordering wall pos vel = 
  pos `compare` wall == ordering && 
  vel `compare` 0    == ordering

colliding :: Ordering -> Scalar -> Scalar -> Scalar -> Incident
colliding ordering wall pos vel = boolToIncident $ isColliding ordering wall pos vel

-------------------------------------------------------------------------------

gameExits :: Sensors -> Trigger
gameExits ss = eitherT (keyDowns (SpecialKey ESC) ss) $ 
                 bothT (rightButtonDowns ss) (leftButtonDowns ss)

-------------------------------------------------------------------------------

wallPic :: Picture
wallPic = mconcat [leftWall, rightWall, topWall, bottomWall]
    
leftWall :: Picture
leftWall = solidPolygonAt (point2 wallLeft 0) (rgb 0 0 1) $
           rectPath wallSize wallHeight

rightWall :: Picture
rightWall =  solidPolygonAt (point2 wallRight 0) (rgb 0 0 1) $
             rectPath wallSize wallHeight

topWall :: Picture
topWall =  solidPolygonAt (point2 0 wallTop) (rgb 0 0 1) $
           rectPath wallWidth wallSize
              
bottomWall :: Picture
bottomWall = solidPolygonAt (point2 0 wallBottom) (rgb 1 0 0) $
             rectPath wallWidth wallSize

-------------------------------------------------------------------------------

render :: GameSample -> Picture
render gs = paddlePic `over` ballsPic `over` wallPic
  where
    paddlePic = solidPolygonAt (actorPos . paddle $ gs) (rgb 1 0 1) $
             rectPath paddleWidth paddleHeight

    ballsPic = mconcat $ ballAt <$> actorPos <$> balls gs

    ballAt :: Point2 -> Picture
    ballAt pos = solidPolygonAt pos (rgb 1 1 0) $ 
                 circlePath ballRadius 36

-------------------------------------------------------------------------------

paddlePositions :: Sensors -> Signal Point2
paddlePositions ss = S.zipWith point2 paddlePosX paddlePosY
  where
    mp              = mousePositions ss
    dt              = tickDurations ss
    paddlePosX      = integral (getX initPaddlePos) paddleVelX dt
    paddlePosY      = pure (getY initPaddlePos)
    paddleVelX      = (getX <$> mp) ^-^ paddlePosX

ballWallHits :: (Signal Point2, Signal Velocity2) -> (Trigger,Trigger)
ballWallHits (ballPos',ballVel') = (hitsX,hitsY)
  where
    ballVelX        = getX <$> ballVel'
    ballVelY        = getY <$> ballVel'
    ballPosX        = getX <$> ballPos'
    ballPosY        = getY <$> ballPos'
    wallOffset      = wallSize + ballRadius
    hitsX           = rising (ballColLeft ~||~ ballColRight)
    hitsY           = rising (ballColTop  ~||~ ballColBottom)
    ballColLeft     = isColliding LT (wallLeft+wallOffset)   
                      <$> ballPosX <*> ballVelX
    ballColRight    = isColliding GT (wallRight-wallOffset)  
                      <$> ballPosX <*> ballVelX 
    ballColBottom   = isColliding LT (wallBottom+wallOffset) 
                      <$> ballPosY <*> ballVelY 
    ballColTop      = isColliding GT (wallTop-wallOffset)    
                      <$> ballPosY <*> ballVelY 

ballPaddleHits :: (Signal Point2, Signal Velocity2) -> Signal Point2 -> 
                  (Trigger,Trigger)
ballPaddleHits (ballPos',ballVel') paddlePos' = (hits,losts)
  where
    ballVelY        = getY <$> ballVel'
    ballPosX        = getX <$> ballPos'
    ballPosY        = getY <$> ballPos'
    paddlePosX      = getX <$> paddlePos'
    paddlePosY      = getY <$> paddlePos'
    ballPaddleZoneY = paddlePosY ^+^ pure (paddleHeight/2 + ballRadius)
    ballColPaddleY  = isColliding LT <$> ballPaddleZoneY <*> ballPosY <*> ballVelY
    ballColPaddleX  = ballPosX ~>~ paddlePosX ^-^ pure (paddleWidth/2) ~&&~
                      ballPosX ~<~ paddlePosX ^+^ pure (paddleWidth/2)
    ballColPaddle   = ballColPaddleX ~&&~ ballColPaddleY
    hits            = rising ballColPaddle
    losts           = rising $ (not <$> ballColPaddle) ~&&~ 
                             ((ballPosY ^+^ pure ballRadius) ~<~ ballPaddleZoneY)

ballKinematics :: Point2 -> Velocity2 -> Sensors -> Trigger -> Trigger -> 
                  (Signal Point2, Signal Velocity2)
ballKinematics initPos initVel ss hitsX hitsY = (pos, vel)
  where
    dt              = tickDurations ss
    ballPosX        = integral (getX initPos) ballVelX dt
    ballPosY        = integral (getY initPos) ballVelY dt
    ballVelX        = S.scan' bounce (getX initVel) hitsX
    ballVelY        = S.scan' bounce (getY initVel) hitsY
    pos             = S.zipWith point2 ballPosX ballPosY
    vel             = S.zipWith vector2 ballVelX ballVelY
    bounce a hit    = maybe a (const $ negate a) hit

bouncingBall :: ID -> Point2 -> Velocity2 -> Signal Point2 -> Sensors -> 
                (Signal Actor, Trigger)
bouncingBall actorID initPos initVel paddlePos' ss = (Ball actorID <$> fst ballKine,losts)
  where
    ballKine        = ballKinematics initPos initVel ss hitsX hitsY
    (wallHitsX,wallHitsY) = ballWallHits ballKine
    (paddleHits,losts) = ballPaddleHits ballKine paddlePos'
    hitsX           = wallHitsX
    hitsY           = wallHitsY `mergeT` paddleHits
    

paddleDemo :: Sensors -> Game
paddleDemo ss = 
  GameSample <$> balls
             <*> paddle
             <*> losts1 `mergeT` losts2 `mergeT` losts3
             <*> gameExits ss
             <*> (dump <$> actorHits)
  where
    paddlePos'      = paddlePositions ss
    paddle          = Paddle 0 <$> paddlePos'
    actorHits       = broadPhaseCollision <$> actorRectIDs
    actorRectIDs    = (fmap $ getBounds &&& actorID) <$> actors
    actors          = section [ball1, ball2, ball3, paddle]
    balls           = section [ball1,ball2, ball3]
    (ball1, losts1) = bouncingBall 1 initBallPos (polar 0 100) paddlePos' ss
    (ball2, losts2) = bouncingBall 2 initBallPos (polar (-1) 100) paddlePos' ss
    (ball3, losts3) = bouncingBall 3 initBallPos (polar 1 100) paddlePos' ss

-------------------------------------------------------------------------------

type SS = SensorsSample

sswitch :: forall a. Signal a -> Sensors -> 
           Event (a -> Sensors -> Signal a) ->
           Signal a
sswitch as ss es = fst <$> switch ass eas
  where
    ass = S.zip as ss
    eas = mapE aux es
      where
        aux :: (a -> Sensors -> Signal a) -> 
               (a,SS) -> Signal (a,SS) -> Signal (a,SS)
        aux f asp sasp = S.zip (f (fst asp) ss') ss'
          where
            ss' = snd <$> sasp

-------------------------------------------------------------------------------

gameLoop :: Sensors -> Game
gameLoop ss = sswitch gs ss (maybeGameOver `mergeE` maybeRestart)
  where
    gs = paddleDemo ss
    maybeGameOver = mapT gameOver (gameLost <$> gs)
    maybeRestart  = mapT (const gameLoop) (rightButtonDowns ss)

gameOver :: GameSample -> Sensors -> Game
gameOver g ss = sswitch gs ss maybeRestart
  where 
    gs = (`withGameExit` g) <$> gameExits ss
    maybeRestart = mapT (const gameLoop) (leftButtonDowns ss)

game :: Sensors -> Pictures
game = map render . S.takeWhile (isNothing . gameExit) . gameLoop

-------------------------------------------------------------------------------

main :: IO ()
main = run game

z :: IO ()
z = main
